// System Unit
// Error Handling

(*************)
(* Interface *)
(*************)
{$IFDEF Include_Modules_Header}

 Type
  TRuntimeError = (
   // OS exception errors
   reExcAccessViolation, reExcArrayBounds,   reExcBreakPoint,    reExcDataAlign,     reExcFPDenormal,
   reExcFPDivZero,       reExcFPInexact,     reExcFPInvalidOp,   reExcFPOverflow,    reExcFPStackOverflow,
   reExcFPUnderflow,     reExcGuardPage,     reExcBadInst,       reExcPageError,     reExcIntDivZero,
   reExcIntOverflow,     reExcInvalidDisp,   reExcInvalidUnwind, reExcInvalidHandle, reExcNonContinue,
   reExcPrivInst,        reExcSingleStep,    reExcStackOverflow,
   // RTL errors
   reNoError,
   reOutOfMemory, reInvalidPtr,   reRangeError,      reInOutError,         reInvalidOp,
   reInvalidCast, reControlBreak, reAssertionFailed, reUnhandledException, reInitFailure,
   reHardware,    reUnimplement
  );

 Type RTLProc_Error = Procedure(ErrorCode: TRuntimeError);
 Var Error: RTLProc_Error = NIL;

 Type RTLProc_NotifyError = Procedure(Const Context: PChar = NIL);
 Var NotifyError: RTLProc_NotifyError = NIL;

 Function RTL_ErrorToExitCode(RTLError: TRuntimeError): Cardinal;
 Function RTL_IsErrorExitCode(ExitCode: Cardinal): Boolean;
 Function RTL_ExitCodeToError(ExitCode: Cardinal): TRuntimeError;
{
 // Compiler Magic
 Procedure _AbstractError;
 Type RTLProc_AbstractError = TProc;

 Procedure _Assert(Const Msg, Filename: String; LineNumber: Integer);
 Type RTLProc_OnAssert = Procedure (Const Msg, Filename: String; LineNumber: Integer; ErrorAddr: Pointer);
 Var OnAssert: RTLProc_OnAssert = NIL;

 Procedure _BoundErr;
 Procedure _IntOver;
 Function _CheckAutoResult(ResultCode: HResult): HResult;
}
 Var
  NoErrMsg: Boolean = False;  { True causes the base RTL to not display the message box
                                when a run-time error occurs }
 //==================
 // RTL Extensions
 //==================
 Type
  TRTLEx_Error = Record
   Error: RTLProc_Error;
   NotifyError: RTLProc_NotifyError;
  END;

 Procedure RTLExtend_Error(Var Ex: TRTLEx_Error);

{$ENDIF Include_Modules_Header}
(******************)
(* Implementation *)
(******************)
{$IFDEF Include_Modules_Implement}

 ResourceString
  _RTL_ResStr_reExcAccessViolation = 'Access Violation';
  _RTL_ResStr_reExcArrayBounds     = 'Array Out-of-bound';
  _RTL_ResStr_reExcBreakPoint      = 'Break Point';
  _RTL_ResStr_reExcDataAlign       = 'Data Alignment Fault';
  _RTL_ResStr_reExcFPDenormal      = 'Floating Point Denormal Operand';

  _RTL_ResStr_reExcFPDivZero       = 'Floating Point Divide-by-Zero';
  _RTL_ResStr_reExcFPInexact       = 'Floating Point Inexact Result';
  _RTL_ResStr_reExcFPInvalidOp     = 'Floating Point Invalid Operation';
  _RTL_ResStr_reExcFPOverflow      = 'Floating Point Overflow';
  _RTL_ResStr_reExcFPStackOverflow = 'Floating Point Stack Overflow';

  _RTL_ResStr_reExcFPUnderflow = 'Floating Point Underflow';
  _RTL_ResStr_reExcGuardPage   = 'Page Guard Triggered';
  _RTL_ResStr_reExcBadInst     = 'Invalid Instruction';
  _RTL_ResStr_reExcPageError   = 'Page Error';
  _RTL_ResStr_reExcIntDivZero  = 'Integer Divide-by-Zero';

  _RTL_ResStr_reExcIntOverflow   = 'Integer Overflow';
  _RTL_ResStr_reExcInvalidDisp   = 'Invalid Disposition';
  _RTL_ResStr_reExcInvalidUnwind = 'Invalid Exception Unwinding';
  _RTL_ResStr_reExcInvalidHandle = 'Invalid Handle';
  _RTL_ResStr_reExcNonContinue   = 'Non-continuable Exception';

  _RTL_ResStr_reExcPrivInst      = 'Privileged Instruction';
  _RTL_ResStr_reExcSingleStep    = 'Single Step Exception';
  _RTL_ResStr_reExcStackOverflow = 'Stack Overflow';

  // RTL errors
  _RTL_ResStr_reNoError = 'No Error';

  _RTL_ResStr_reOutOfMemory = 'Out of Memory';
  _RTL_ResStr_reInvalidPtr  = 'Invalid Pointer';
  _RTL_ResStr_reRangeError  = 'Range Check Error';
  _RTL_ResStr_reInOutError  = 'Input/Output Error';
  _RTL_ResStr_reInvalidOp   = 'Invalid Operation';

  _RTL_ResStr_reInvalidCast        = 'Invalid Type Cast';
  _RTL_ResStr_reControlBreak       = 'Control-Break';
  _RTL_ResStr_reAssertionFailed    = 'Assertion Failure';
  _RTL_ResStr_reUnhandledException = 'Unhandled Exception';
  _RTL_ResStr_reInitFailure        = 'Initialization Failure';

  _RTL_ResStr_reHardware    = 'Unsupported Hardware';
  _RTL_ResStr_reUnimplement = 'Unimplemented Function';

  _RTL_ResStr_ErrorTitle = 'Critical Error';
  _RTL_ResStr_ErrorDesc = 'Runtime library error:';
  _RTL_ResStr_ErrorReraise = '(Cascade)';
  _RTL_ResStr_ErrorContext = 'Context:';

 Const
  _INT_RuntimeErrorMap: Array [TRuntimeError] of PResStringRec =
  (
   @_RTL_ResStr_reExcAccessViolation,
   @_RTL_ResStr_reExcArrayBounds,
   @_RTL_ResStr_reExcBreakPoint,
   @_RTL_ResStr_reExcDataAlign,
   @_RTL_ResStr_reExcFPDenormal,

   @_RTL_ResStr_reExcFPDivZero,
   @_RTL_ResStr_reExcFPInexact,
   @_RTL_ResStr_reExcFPInvalidOp,
   @_RTL_ResStr_reExcFPOverflow,
   @_RTL_ResStr_reExcFPStackOverflow,

   @_RTL_ResStr_reExcFPUnderflow,
   @_RTL_ResStr_reExcGuardPage,
   @_RTL_ResStr_reExcBadInst,
   @_RTL_ResStr_reExcPageError,
   @_RTL_ResStr_reExcIntDivZero,

   @_RTL_ResStr_reExcIntOverflow,
   @_RTL_ResStr_reExcInvalidDisp,
   @_RTL_ResStr_reExcInvalidUnwind,
   @_RTL_ResStr_reExcInvalidHandle,
   @_RTL_ResStr_reExcNonContinue,

   @_RTL_ResStr_reExcPrivInst,
   @_RTL_ResStr_reExcSingleStep,
   @_RTL_ResStr_reExcStackOverflow,

   // RTL errors
   @_RTL_ResStr_reNoError,

   @_RTL_ResStr_reOutOfMemory,
   @_RTL_ResStr_reInvalidPtr,
   @_RTL_ResStr_reRangeError,
   @_RTL_ResStr_reInOutError,
   @_RTL_ResStr_reInvalidOp,

   @_RTL_ResStr_reInvalidCast,
   @_RTL_ResStr_reControlBreak,
   @_RTL_ResStr_reAssertionFailed,
   @_RTL_ResStr_reUnhandledException,
   @_RTL_ResStr_reInitFailure,

   @_RTL_ResStr_reHardware,
   @_RTL_ResStr_reUnimplement
  );

 Type
  _INT_PRTLErrorRec = ^_INT_RTLErrorRec;
  _INT_RTLErrorRec = Record
   Flags: NativeUInt;
   Error: TRuntimeError;
  END;

 Const
  _INT_RTLErrorException = $0BADFAD0;
  _INT_ErrorFlag_Reraise = $80000000;

 ThreadVar
  _INT_RTLError: _INT_RTLErrorRec;

 Procedure _INT_ResetError;
  BEGIN
   _INT_RTLError.Error:= reNoError;
   _INT_RTLError.Flags:= 0;
  END;

 Procedure _RTL_Error(ErrorCode: TRuntimeError);
  Const
   EXCEPTION_NONCONTINUABLE = $00000001;
  Var
   ErrorRec: _INT_RTLErrorRec;
  BEGIN
   ErrorRec.Error:= errorCode;
   ErrorRec.Flags:= 0;
   // Except into the upper level function (In this case, the Library/DLL/EXE main function)
   _WIN_RaiseException(_INT_RTLErrorException, EXCEPTION_NONCONTINUABLE, 2, @ErrorRec);
  END;

 // Internal unified error message formatter
 // Note: Buffer has to be (at least) RTL_ResStr_MsgLen*3+4+1 bytes long
 Procedure _INT_RTLErrorMsgFmt(Const ErrorRec: _INT_RTLErrorRec; Buffer: PChar; Const Context: PChar = NIL);
  Var
   MsgLen: Cardinal;
  BEGIN
   MsgLen:= LoadResStringFx(@_RTL_ResStr_ErrorDesc, Buffer, RTL_ResStr_MsgLen+1);
   Buffer[MsgLen]:= ' '; Inc(MsgLen);
   Inc(MsgLen, LoadResStringFx(_INT_RuntimeErrorMap[ErrorRec.Error], @Buffer[MsgLen], RTL_ResStr_MsgLen-MsgLen+1));

   IF ErrorRec.Flags AND _INT_ErrorFlag_Reraise <> 0 then
    BEGIN
     Buffer[MsgLen]:= ' '; Inc(MsgLen);
     Inc(MsgLen, LoadResStringFx(@_RTL_ResStr_ErrorReraise, @Buffer[MsgLen], RTL_ResStr_MsgLen-MsgLen+1));
    END;

   IF Assigned(Context) then
    BEGIN
     Buffer[MsgLen]:= #13; Buffer[MsgLen+1]:= #10; Inc(MsgLen, 2);
     Inc(MsgLen, LoadResStringFx(@_RTL_ResStr_ErrorContext, @Buffer[MsgLen], RTL_ResStr_MsgLen*2+1));
     Buffer[MsgLen]:= ' '; Inc(MsgLen);
     RTL_PWideCharCopyNPtr(@Buffer[MsgLen], Context, RTL_ResStr_MsgLen*2-MsgLen+1)^:= #0;
    END;
  END;

 Procedure _INT_LogRTLError(ErrorRec: _INT_RTLErrorRec; Const LogLevel: RTL_LogLevel = llFatal; Const Context: PChar = NIL);
  Var
   ErrorMsg: Array [0..RTL_ResStr_MsgLen*3+4] of Char;
  BEGIN
   _INT_RTLErrorMsgFmt(ErrorRec, ErrorMsg, Context);
   Log(LogLevel, ErrorMsg);
  END;

 Procedure _RTL_NotifyError(Const Context: PChar = NIL);
  Const
   MB_OK                    = $00000000;
   MB_ICONERROR             = $00000010;
   MB_TASKMODAL             = $00002000;
   MB_SETFOREGROUND         = $00010000;
   MB_DEFAULT_DESKTOP_ONLY  = $00020000;
  Var
   ErrorTitle: Array [0..RTL_ResStr_CapLen] of Char;
   ErrorMsg: Array [0..RTL_ResStr_MsgLen*3+4] of Char;
  BEGIN
   IF NOT NoErrMsg then
    BEGIN
     LoadResStringFx(@_RTL_ResStr_ErrorTitle, @ErrorTitle[0], RTL_ResStr_CapLen+1);
     _INT_RTLErrorMsgFmt(_INT_RTLError, ErrorMsg, Context);
     _WIN_MessageBox(0, ErrorMsg, ErrorTitle, MB_OK OR MB_TASKMODAL OR MB_SETFOREGROUND OR MB_DEFAULT_DESKTOP_ONLY OR MB_ICONERROR);
    END;
  END;

 Const
  _INT_RTLErrorExit = $BADFAD00;
  _INT_RTLErrorMask = $FFFFFF00;

 Function RTL_ErrorToExitCode(RTLError: TRuntimeError): Cardinal;
  BEGIN
   Result:= _INT_RTLErrorExit OR Cardinal(RTLError);
  END;

 Function RTL_IsErrorExitCode(ExitCode: Cardinal): Boolean;
  BEGIN
   Result:= (ExitCode AND _INT_RTLErrorMask) AND _INT_RTLErrorExit = _INT_RTLErrorExit;
  END;

 Function RTL_ExitCodeToError(ExitCode: Cardinal): TRuntimeError;
  BEGIN
   IF NOT RTL_IsErrorExitCode(ExitCode)
   then Error(reInvalidOp);

   Result:= TRuntimeError(ExitCode AND NOT _INT_RTLErrorMask);
  END;

 //==================
 // RTL Extensions
 //==================

 Procedure RTLExtend_Error(Var Ex: TRTLEx_Error);
  BEGIN
   _INT_RTL_DoEx(@Error, @Ex.Error);
   _INT_RTL_DoEx(@NotifyError, @Ex.NotifyError);
  END;

 Procedure _INT_Error_Init;
  BEGIN
   Error:= _RTL_Error;
   NotifyError:= _RTL_NotifyError;
  END;

{$ENDIF Include_Modules_Implement}
(******************)
(* Initialization *)
(******************)
{$IFDEF Include_Modules_Initialize}

 _INT_ResetError;

{$ENDIF Include_Modules_Initialize}
(****************)
(* Finalization *)
(****************)
{$IFDEF Include_Modules_Finalize}
{$ENDIF Include_Modules_Finalize}
